#lang racket/base

#|
INBOUND-QUE : que for inbound messages (list idnum msg)
OUTBOUND- : que for outbound messages (list idnum msg) -1 mean broadcast
CON-QUE : que of all connections
CUR-ID : next id to be assigned to a connection
KILL-QUE : que of players to be killed
PORT : port server runs on
MAX-WAIT : max number of players that can be waiting to connect at any time

struct conect : [id number] [reader thread] [in input-port] [out output-port]
     contains all info for a player connection

add-outbound : message -> void
    adds a message to the OUTBOUND-QUE

add-kill : idnum -> void
   adds a id to the KILL-QUE

start : [#:on-c (id -> any)] [#:on-msg (id message -> any)] [#:on-d (id -> void)] -> (->)
   starts a server and returns a thunk to kill it

a message is a (list idnum sexpr)
|#

(require racket/tcp racket/list "server-base-data.rkt" (only-in racket/function negate))
(provide (except-out (all-defined-out)
                     thunk push pop tail-pop tail-pop-acc clear remove-conect!
                     listen handle killer clear-outbound clear-inbound newline
                     RUNNING-CUST))

(define debug (make-parameter #f))

(define-syntax thunk
  (syntax-rules ()
    [(_ a ...)
     (λ () a ...)]))

(define-syntax push
  (syntax-rules ()
    [(_ a b)
     (set! b (cons a b))]))

(define-syntax pop
  (syntax-rules ()
    [(_ a)
     (begin0 (last a)
             (set! a (tail-pop a)))]))

(define (tail-pop l)
  (tail-pop-acc l null))

(define (tail-pop-acc l acc)
  (cond [(or (null? l) (null? (rest l)))
         null]
        [else (tail-pop (rest l) (cons (first l) acc))]))

(define-syntax clear
  (syntax-rules ()
    [(_ a)
     (begin0 (reverse a)
             (set! a null))]))

(define-syntax remove-conect!
  (syntax-rules ()
    [(_ r l)
     (begin0 (findf (λ (c) (= (conect-id c) r)) l)
             (set! l (remove r l (λ (r c) (= r (conect-id c))))))]))


(define debug-port (make-parameter (current-output-port)))
(define (newline) (displayln "" (debug-port)))
(define-syntax debug-msg
  (syntax-rules ()
    ([_ msgs ...]
     (when (debug)
       (display msgs (debug-port)) ...
       (newline)))))

(define INBOUND-QUE null)
(define OUTBOUND-QUE null)
;; a connection is a (conect Number thread inputport outputport)
(struct conect (id in out) #:transparent)
(define CON-QUE null)
(define CUR-ID 0)
(define KILL-QUE null)
(define PORT 6874)
(define MAX-WAIT 4)
(define RUNNING-CUST (make-custodian))

;; Server Start
;; -----------------------------------------------------------------------------

;; #:on-c (id -> any) #:on-msg (id message -> any) #:on-d (id -> void) -> (->) #:on-t (-> any)
;; starts server. returns function to shut it all down
(define (start #:on-c [on-c (λ (c) (void))]
               #:on-msg [on-m (λ (id m) (void))]
               #:on-d [on-d (λ (id) (void))]
               #:on-t [on-t (λ () (void))]
               #:port [port PORT]
               #:max-wait [max-wait MAX-WAIT]
               #:hostname [hostname #f])
  (parameterize ([current-custodian RUNNING-CUST])
    (let ([serv (thread (thunk (server-thread on-m on-d on-t)))]
          [lstn (thread listener)]
          [s (start-server (λ (in out) (handle in out on-c)) port max-wait hostname)])
      (λ () 
        (kill-thread serv) (kill-thread lstn)
        (for ([c CON-QUE])
          (drop-conect c))
        (set! CON-QUE null)
        (set! INBOUND-QUE null) (set! OUTBOUND-QUE null)
        (set! CUR-ID 0)
        (set! KILL-QUE null)
        (s)))))

;; -> (void)
;; for kill the server
(define (force-kill)
  (custodian-shutdown-all RUNNING-CUST))

;; conect -> (void)
;; dissconectes this connection
(define (drop-conect c)
  (when (not (port-closed? (conect-out c)))
    (tcp-abandon-port (conect-out c)))
  (when (not (port-closed? (conect-in c)))
    (tcp-abandon-port (conect-in c))))

;; Connection-Handler port-no [number 4] -> (->)
;; launches the tcp loop and returns a function to shut it down
(define (start-server handler port [max-wait 4] [hostname #f])
  (define listener (tcp-listen port max-wait #f hostname))
  (define (loop)
    (when (tcp-accept-ready? listener)
      (define-values (in out) (tcp-accept listener))
      (handler in out))
    (loop))
  (define server (thread loop))
  
  (λ () 
    (kill-thread server)
    (tcp-close listener)))

;; Port Control
;; -----------------------------------------------------------------------------

;; input-port outputport (id -> any) (id -> any) -> (void)
;; handles new connection. calls on-connect and adds it to con-que. lauches read thread.
(define (handle in out on-connect)
  (define id CUR-ID)
  (set! CUR-ID (add1 CUR-ID))
  (define c (conect id in out))
  (push c CON-QUE)
  (debug-msg "new client: " id)
  (on-connect id))

;; -> (void)
;; listens for new messages
(define (listener)
  (unless (empty? CON-QUE)
    (apply sync
           (for/list ([c CON-QUE])
             (handle-evt (conect-in c) 
                         (λ (in)
                           (listen (conect-id c) in))))))
  (listener))

;; idnum inputport (id -> any) -> void
;; listends to aport. adds a drop connection to kill-que
(define (listen id port)
  (with-handlers ([exn:fail:read? 
                   (λ (e) 
                     (debug-msg "client " id " sent an illegaly formated message.")
                     (debug-msg "read error was: " e))]
                  [exn:fail? (λ (e) (add-kill id))])
    (when (not (memq id KILL-QUE))
      (define msg (read-line port))
      (cond [(eof-object? msg)
             (add-kill id)]
            [else
              (define r (read (open-input-string msg)))
              (push (list id r) INBOUND-QUE)]))))

;; Que Watchers
;; -----------------------------------------------------------------------------

;; (id sexpr -> any) (id -> any) (-> any) -> (void)
;; runs over server tick
(define (server-thread on-m on-dis on-tick)
  (on-tick)
  (messager on-m)
  (killer on-dis)
  (sender)
  (server-thread on-m on-dis on-tick))

;; -> void
;; sends outbound list and clears it
(define (sender)
  (define ms (clear-outbound))
  (for ([m ms])
    (debug-msg  "sending: " (message-msg m)  " to " (message-id m))
    (cond [(broadcast? m)
           (for ([con CON-QUE])
             (send con m))
           (debug-msg "all sent")]
          [else (define con (find-conect (message-id m)))
                (when con
                  (send con m))])))

;; message -> boolean
;; is this message for broadcast?
(define (broadcast? m)
  (= -1 (message-id m)))

;; id -> [Or conect #f]
;; finds the connect
(define (find-conect id)
  (findf (λ (c) (= (conect-id c) id)) CON-QUE))

;; conect msg -> void
;; sends a message
(define (send con m)
  (with-handlers ([exn:fail:network? (λ (e) (debug-msg "send failed!"))])
    (displayln (message-msg m) (conect-out con))
    (flush-output (conect-out con))
    (debug-msg "message sent!")))
  

;; (id sexpr -> any) (-> any) -> void
;; clears inbound and calls message handleer on all of em
(define (messager mer)
  (define ms (clear-inbound))
  (for ([m ms])
    (debug-msg "recieved: " (second m) " from " (first m))
    (mer (first m) (second m))))

;; (id -> any) -> void
;; clears kill-que, drop clients, call drop handler
(define (killer on-d)
  (define kills (clear KILL-QUE))
  (for ([id kills])
    (debug-msg id " dropped")
    (when (findf (λ (c) (= id (conect-id c))) CON-QUE)
      (define c (remove-conect! id CON-QUE))
      (with-handlers ([exn:fail:network? (λ (e) (void))])
        (drop-conect c))
      (on-d id))))

;; Interface Functions
;; -----------------------------------------------------------------------------

;; -> (listof messages)
;; clears outbound que and returns it
(define (clear-outbound)
  (clear OUTBOUND-QUE))

;; -> void
;; adds a messages to the outbound que
(define (add-outbound msg)
  (push msg OUTBOUND-QUE))

;; -> (listof messages)
;; whipes inbound que and returns it
(define (clear-inbound)
  (clear INBOUND-QUE))

;; idnum -> (void)
;; adds an id to the kill que
(define (add-kill id)
  (push id KILL-QUE))